begin "tftopl" comment PL file maker;

comment
edited by Ramshaw, December 10, 1980  9:40 PM
	changed names of codingschemes as per request of DEK

edited by Ramshaw, November 13, 1980  10:38 AM
	changed to scalable TFM format, and corresponding PL
	allow eight bit character codes

edited by Knuth, December 13, 1979
	added "extraspace" parameter

edited by Wyatt,  September 4, 1979  8:10 AM
	new PL format
edited by Wyatt,  May 5, 1979  12:38 PM
	derives family name from input file name
edited by Wyatt,  April 27, 1979  3:04 PM
	now understands special math font info in sy and ex fonts
edited by Wyatt,  September 27, 1978  4:15 PM
	changes for new TFP file format
edited by Guibas,  August 29, 1978  5:06 PM;


require "⊂⊃⊂⊃" delimiters;
DEFINE WAITS=TRUE, TENEX=FALSE;

define #=⊂;comment ⊃;
define thru=⊂step 1 until⊃;
define crlf=⊂('15&'12)⊃;
define DEBUG=⊂comment⊃ # change to ⊂comment⊃ for debugged version;
define simp=⊂simple⊃;
define saf=⊂safe⊃;
DEBUG redefine simp=⊂⊃;
DEBUG redefine safe=⊂⊃;

integer ochan;
IFC WAITS THENC
integer count, brchar, eof, ocount, obrchar, oeof;
ENDC

define Ws(s)=⊂cprint(ochan, s)⊃;
define Wr(n)=⊂cprint(ochan, " R ",n)⊃;
define Wd(n)=⊂cprint(ochan, " D ",n)⊃;
define Wo(n)=⊂cprint(ochan, " O ",cvos(n))⊃;
define Wx(n)=⊂cprint(ochan, " R ",cvf((n ash -4)/(2↑20)))⊃;

define printable(char)=⊂(not extfont) and
	((("0"≤char) and (char≤"9")) or (("A"≤char) and (char≤"Z")) or
	(("a"≤char) and (char≤"z")))⊃;
define WChar(char)=⊂if printable(char)
		then cprint(ochan, " C "&char) else Wo(char)⊃;


integer chan, lev; string fonttype; boolean symbolfont, extfont;
boolean sevenbitsafe,sevenbitsafeclaim;

comment offsets in header array;
define
	checksumofst=0,
	designsizeofst=1,
	codingschemeofst=2,
	familyofst=12,
	randomofst=17;

comment sizes and positions of fields in finfo;
define wds=8, hts=4, dps=4, ics=6, tgs=2, rems=8;
define remd=4;
define tgd=remd+rems, icd=tgd+tgs, dpd=icd+ics, htd=dpd+dps, wdd=htd+hts;

comment sizes and positions of fields in ligkern program;
define lsbs=1, unused1s=7, lncs=8, ltgs=1, unused2s=7, lrems=8;
define lremd=4;
define ltgd=lremd+lrems+unused2s, lncd=ltgd+ltgs, lsbd=lncd+lncs+unused1s;

define tagnone=0, taglig=1, taglist=2, tagvar=3;
define ligstep=0, kernstep=1;

define fs(f)=⊂f⊃&"s";
define fd(f)=⊂f⊃&"d";
define field(f,x)=⊂(((x)lsh -fd(f))land(2↑fs(f)-1))⊃;

define lefthalf(x)=⊂(x lsh -20)⊃;
define righthalf(x)=⊂((x lsh -4)land((1 lsh 16) -1))⊃;

preload_with "SLANT","SPACE","STRETCH","SHRINK","XHEIGHT","QUAD";
string array pnames[1:6];
preload_with "NUM1","NUM2","NUM3","DENOM1","DENOM2","SUP1","SUP2","SUP3",
	 "SUB1","SUB2","SUPDROP","SUBDROP","DELIM1","DELIM2","AXISHEIGHT";
string array snames[8:22];
preload_with "DEFAULTRULETHICKNESS","BIGOPSPACING1","BIGOPSPACING2",
	 "BIGOPSPACING3","BIGOPSPACING4","BIGOPSPACING5";
string array enames[8:13];

preload_with "TOP","MID","BOT","EXT";
string array xnames[1:4];

external procedure bail;

simp procedure cr;
	begin
	integer i;
	cprint(ochan,crlf);
	for i←1 thru lev do cprint(ochan, "	");
	end;

simp procedure bg;
	begin
	cprint(ochan, "(");
	lev←lev+1;
	end;

simp procedure ndd;
	begin
	lev←lev-1;
	cprint(ochan, ")"); cr;
	end;

simp string procedure getBCPL(integer ptr);
	begin
	integer i,len,bp; string res;
	bp←point(8,memory[ptr],-1);
	len←ildb(bp);  res←null;
	for i←1 thru len do res←res&(ildb(bp));
	return(res);
	end;

simp string procedure decodeface(integer f);
	begin
	integer w,s,e # weight, slope, expansion;
	s←case f mod 2 of ("R","I");
	f←f div 2;
	w←case f mod 3 of ("M","B","L");
	f←f div 3;
	e←case f mod 3 of ("R","C","E");
	return(w&s&e);
	end;

simp string procedure getface(integer f);
	begin
	f←f land '377;
	if f≥18 then return(" O "&cvos(f))
	 else return(" F "&decodeface(f));
	end;

procedure doit;
begin "doit"
integer lf,lh,bc,ec,nw,nh,nd,ni,nl,nk,ne,np,data;
data←wordin(chan);
lf←lefthalf(data);  lh←righthalf(data);
data←wordin(chan);
bc←lefthalf(data);  ec←righthalf(data);
data←wordin(chan);
nw←lefthalf(data);  nh←righthalf(data);
data←wordin(chan);
nd←lefthalf(data);  ni←righthalf(data);
data←wordin(chan);
nl←lefthalf(data);  nk←righthalf(data);
data←wordin(chan);
ne←lefthalf(data);  np←righthalf(data);
	begin "dynamic array allocate"
	comment  All these arrays are one word longer than necessary,
		since SAIL won't allow you to declare an empty array!;
	integer array header[0:lh];
	saf integer array finfo[bc:ec+1];
	integer array charwd[0:nw];
	integer array charht[0:nh];
	integer array chardp[0:nd];
	integer array charic[0:ni];
	integer array ligkern[0:nl];
	integer array kern[0:nk];
	integer array ext[0:ne];
	integer array fontpar[1:np+1];

	procedure doparams;
		begin "doparams"
		integer i;
		for i←1 thru 6 do
			begin
			bg; Ws(pnames[i]); Wx(fontpar[i]); ndd;
			end;
		bg; Ws(if symbolfont then "MATHSPACE" else "EXTRASPACE");
		  Wx(fontpar[7]); ndd;
		if symbolfont then
			for i←8 thru 22 do
			 begin bg; Ws(snames[i]); Wx(fontpar[i]); ndd end
		 else if extfont then
			for i←8 thru 13 do
			 begin bg; Ws(enames[i]); Wx(fontpar[i]); ndd end;
		end "doparams";

	procedure dolabels(integer i);
		begin integer c;
		for c←bc thru ec do
		  if field(tg,finfo[c])=taglig and
		     field(rem,finfo[c])=i then
			begin bg; Ws("LABEL"); WChar(c); ndd end;
		end;

	boolean procedure dolig(integer lgindex);
		comment returns stop bit as value;
		begin integer lgentry, nxtchar, rem;
		lgentry←ligkern[lgindex];
		nxtchar ← field(lnc,lgentry);
		rem ← field(lrem,lgentry);
		case field(ltg,lgentry) of
		  begin
		   [ligstep]
			begin
			bg; Ws("LIG"); WChar(nxtchar); WChar(rem); ndd;
			end;
		   [kernstep]
			begin
			bg; Ws("KRN"); WChar(nxtchar); Wx(kern[rem]); ndd;
			end
		  end;
		return(field(lsb,lgentry));
		end;

	procedure doligtable;
		begin integer lgindex;
		if nl=0 then return # empty ligtable;
		bg; Ws("LIGTABLE"); cr;
		for lgindex←0 thru nl-1 do
			begin
			dolabels(lgindex);
			if dolig(lgindex) then 
			  begin bg; Ws("STOP"); ndd end;
			end;
		ndd;
		end;

	procedure dovarchar(integer vcentry);
		begin integer j,ecd;
		comment extensible character;
		define ecs=8;
		ecd←36 # bitsperwd;
		bg; Ws("VARCHAR"); cr;
		for j←1 thru 4 do
			begin integer c;
			ecd←ecd-ecs; c←field(ec,vcentry);
			if c neq 0 then
			  begin bg; Ws(xnames[j]); WChar(c); ndd end;
			end;
		ndd;
		end;

	boolean procedure unsafevarchar(integer vcentry);
		begin integer j,ecd;
		define ecs=8;
		ecd←36 # bitsperwd;
		for j←1 thru 4 do
			begin integer c;
			ecd←ecd-ecs; c←field(ec,vcentry);
			if c≥'200 then return(true);
			end;
		return(false);
		end;

	boolean procedure checksafe;
		begin
		comment this procedure computes from the basic TFM
			data whether or not the file is sevenbitsafe;
		integer char,lig;
		for char←bc thru (ec min '177) do
		 case field(tg,finfo[char]) of
		  begin
		  [tagnone] ;
		  [taglig] 
			begin integer l, step, nxtchar, rem;
			l←field(rem,finfo[char]);
			while true do
				begin
				step←ligkern[l];
				nxtchar←field(lnc,step);
				rem←field(lrem,step);
				if nxtchar<'200 and field(ltg,step)=ligstep
				  and rem≥'200 then return(false);
				if field(lsb,step) then done;
				l←l+1;
				end;
			end;
		  [tagvar] if unsafevarchar(ext[field(rem,finfo[char])]) then
				return(false);
		  [taglist] if field(rem,finfo[char])≥'200 then return(false)
		  end;
		return(true);
		end;

	integer char;

	
	comment *** Read in the data of the .tfm file ***;
	arryin(chan,header[0],lh);
	arryin(chan,finfo[bc],ec-bc+1);
	arryin(chan,charwd[0],nw);
	arryin(chan,charht[0],nh);
	arryin(chan,chardp[0],nd);
	arryin(chan,charic[0],ni);
	arryin(chan,ligkern[0],nl);
	arryin(chan,kern[0],nk);
	arryin(chan,ext[0],ne);
	arryin(chan,fontpar[1],np);
	
	lev←0;
	sevenbitsafe←checksafe;
	comment Output header data;
	bg; Ws("FAMILY "); Ws(getBCPL(location(header[familyofst]))); ndd;
	bg; Ws("FACE "); Ws(getface(header[randomofst] lsh -4)); ndd;
	fonttype←getBCPL(location(header[codingschemeofst]));
	symbolfont←equ(fonttype,"TEX MATHSY");
	extfont←equ(fonttype,"TEX MATHEX");
	bg; Ws("CODINGSCHEME "); Ws(fonttype); ndd;
	bg; Ws("CHECKSUM "); Wo(header[checksumofst] lsh -4); ndd;
	bg; Ws("DESIGNSIZE "); Wx(header[designsizeofst]); ndd;
	sevenbitsafeclaim←if header[randomofst]<0 then true else false;
	bg; Ws("SEVENBITSAFEFLAG ");  if sevenbitsafeclaim then
		Ws("TRUE") else Ws("FALSE"); ndd;
	if sevenbitsafe and not sevenbitsafeclaim then
		begin bg; Ws("COMMENT This font actually is seven bit safe.");
		ndd; end;
	if not sevenbitsafe and sevenbitsafeclaim then
		begin bg;
	  Ws("COMMENT Danger!  This font is NOT actually seven bit safe!");
		ndd; end;
	bg; Ws("UNITS EMS"); ndd;
	bg; Ws("TEXINFO"); cr; doparams; ndd;
	doligtable;
	for char ← bc thru ec do
		begin integer index,charinfo;
		define code(x)=⊂field(x,charinfo)⊃;
		charinfo←finfo[char];
		if charinfo=0 then continue # non-existent character;

		print(" ",cvos(char));

		bg; Ws("CHARACTER"); WChar(char); cr;

		index ← code(wd);
		bg; Ws("CHARWD"); Wx(charwd[index]); ndd;

		index ← code(ht);
		bg; Ws("CHARHT"); Wx(charht[index]); ndd;

		index ← code(dp);
		bg; Ws("CHARDP"); Wx(chardp[index]); ndd;

		index ← code(ic);
		if index≠0 then
		 begin bg; Ws("CHARIC"); Wx(charic[index]); ndd; end;

		case code(tg) of
		  begin
		  [tagnone] ;
		  [taglig]  
			begin integer l;
			l←code(rem);
			bg; Ws("COMMENT"); cr;
			while not dolig(l) do l←l+1;
			ndd;
			end;
		  [tagvar]  dovarchar(ext[code(rem)]);
		  [taglist]
			begin bg; Ws("NEXTLARGER"); WChar(code(rem)); ndd; end
		  end;
		ndd # of CHARACTER;
		end;
	end "dynamic array allocate";
end "doit";

boolean procedure openinputfile;
	begin "openinputfile"
	string name; integer i, c; string array namef[1:3];
	external integer !skip!;
	while true do
		begin
		print("TFM input file: ");
IFC TENEX THENC
		release(chan) # close old input if any;
		chan←gtjfnl(null,'100100000000,'000100000101,
			null,null,null,"TFM",null,null,0);
		if !skip!≠0 then
			begin print(crlf, "What?", crlf); continue end;
		openf(chan,2);
		if !skip!≠0 then 
			begin print(crlf, "Can't open that file!", crlf);
			continue end;
ENDC
IFC WAITS THENC
		open(chan←getchan,"DSK",8,19,0,count,brchar,eof);
		open(ochan←getchan,"DSK",0,0,19,ocount,obrchar,oeof);
		name←inchwl;
		namef[1]←namef[2]←namef[3]←"";
		i←1;
		while c←lop(name) do begin
			if c="." then i←2
			else if c="[" then i←3;
			namef[i]←namef[i]&c;
			end;
		if namef[2]="" then namef[2]←".TFM";
		if namef[3]="" then name←namef[1]&namef[2]&"[TEX,SYS]"
		else name←namef[1]&namef[2]&namef[3];
		lookup(chan,name,eof);
		if eof then begin
			print(crlf, "Can't open ",name,crlf); continue end;
		name←namef[1]&".PL"&namef[3];
		enter(ochan,name,oeof);
		if oeof then begin
			print(crlf, "Can't open ",name,crlf); continue end;
ENDC
		return(true)
		end;
	end "openinputfile";

comment Main code starts here;
print("TFTOPL of December 10, 1980",crlf);
IFC WAITS THENC
openinputfile;
doit;
print(crlf);
release(chan); release(ochan);
ENDC
IFC TENEX THENC
while openinputfile do 
   do	begin
	string filename, outfilename;
	filename←jfns(chan, '001000000000) # name part only, not extension;
	outfilename←filename&".PL";
	ochan←openfile(outfilename,"WA");
	print(crlf,"PL output file: ",jfns(ochan,0),crlf);
	doit;
	release(ochan);
	print(crlf);
	end until not indexfile(chan);
ENDC

end "tftopl";